perm filename PR4[1,DBL] blob
sn#011041 filedate 1972-12-12 generic text, type T, neo UTF8
00100 BEGIN
00200 EXPR GETVARS(E);
00300 ORDER(OUTNIL(FLATTEN(E)));
00400 EXPR OUTNIL(L);
00500 BEGIN NEW M;
00600 FOR NEW I IN L DO
00700 BEGIN
00800 IF I = 'C THEN I←'CC; IF I='D THEN I←'DD;
00900 IF NOT(MEMBER(I,'(NIL PLUS MINUS TIMES EXPT))
01000 OR MEMBER(I,M) OR NUMBERP(I)) THEN M← I CONS M; RETURN M; END;
01100 RETURN M; END;
01200 EXPR NVARS(E); LENGTH(GETVARS (E));
01300 EXPR DEL1(I,AA);
01400 FOR NEW J IN CDR(AA) COLLECT <(J↑(I-1)) @ (SUFLIST (J,I))>;
01500 EXPR PMATRIX(AA);
01600 FOR NEW I IN A DO BEGIN PRINT I; END;
01700 EXPR GENARGS(NV,LP);
01800 FOR NEW D←1 TO LP COLLECT
01900 <FOR NEW V←1 TO NV COLLECT <REMAINDER ((EXPT(V,D) -
02000 V*D -V - D - 23),
02100 17)- 9>>;
02200 EXPR GENTARG(NV,DEG);
02300 FOR NEW V←1 TO NV COLLECT <V*(5-DEG*4)>;
02400 EXPR GENMATRIX(DEG,INPUT,VARS,LP);
02500 BEGIN NEW G,AA,BB,ZZ,NV;
02600 NV←LENGTH(VARS);
02700 ZZ ← ZV(NV,INPUT,VARS);
02800 G←GENARGS(NV,LP-1 );
02900 FOR NEW I←1 TO LP-1 DO BEGIN
03000 FOR NEW J←1 TO NV DO SET(VARS[J],G[I,J]);
03100 AA[I]←(POLY(DEG,NV,VARS) ↑ (LP-1));
03200 BB[I]←( EVAL(INPUT))-ZZ; END;
03300 RETURN (AA CONS BB CONS ZZ); END;
03400 EXPR GETCO(DEG,INPUT,VARS,LP);
03500 BEGIN NEW G,AA,BB;
03600 G←GENMATRIX(DEG,INPUT,VARS,LP);
03700 AA←G[1]; BB←G[2]; ZZ←CDDR(G);
03800 RETURN ( SOLVE(AA,BB) @ <ZZ>) ; END;
03900 EXPR TESTCO(C,VARS,DEG,INPUT,LP);
04000 BEGIN NEW G,NV;
04100 NV←LENGTH(VARS);
04200 G←GENTARG(NV, LP);
04300 FOR NEW I←1 TO NV DO SET(VARS[I],G[I]);
04400 IF EVAL('PLUS CONS (C * ⊗ POLY(DEG,NV,VARS)))
04500 = EVAL(INPUT) THEN RETURN T ELSE RETURN NIL; END;
04600 EXPR TRY(DEG,VARS,INPUT);
04700 BEGIN NEW C;
04800 LP← LPOLY(DEG, LENGTH(VARS));
04900 IF DEG=0 THEN C←<ZV(LENGTH(VARS),INPUT,VARS)> ELSE
05000 C← GETCO(DEG,INPUT,VARS,LP);
05100 IF TESTCO(C,VARS,DEG,INPUT,LP) OR DEG=4 THEN RETURN (C CONS DEG)
05200 ELSE RETURN TRY(DEG+1,VARS,INPUT); END;
05300 EXPR SF(E);
05400 BEGIN NEW VARS,R,C,DEG;
05500 VARS←GETVARS(E);
05600 E←ALTER(E);
05700 R← TRY(0,VARS,E);
05800 C←R[1];
05900 DEG← CDR(R);
06000 TERPRI(NIL);TERPRI(NIL);PRINTSTR '"DEGREE ";
06100 PRINT DEG; PRINTSTR '"MY STANDARD FORM IS"; PRINT C;
06200 PRINTSTR '"YOUR STANDARD FORM IS";
06300 SFPRINT(VARS,DEG,C); TERPRI(NIL); E END;
06400 EXPR FLATTEN(S);
06500 IF ATOM(S) THEN <S>
06600 ELSE FLATTEN(CAR(S)) @ FLATTEN(CDR (S));
06700 EXPR ORDER(L);
06800 BEGIN FOR NEW KOUNTR←1 TO LENGTH(L) DO
06900 FOR NEW J←1 TO LENGTH(L)-1 DO
07000 FOR NEW I←J TO LENGTH(L)-1 DO
07100 IF ORDERP(L[I+1],L[I]) THEN BEGIN NEW TEMP;
07200 TEMP←L[I]; L[I]←L[I+1]; L[I+1]←TEMP;
07300 RETURN L; END; RETURN L; END;
07400
07500 DSKIN(ORDERFILE);
07600 EE ← '(TIMES 20 (PLUS (TIMES 3 B (EXPT A 2)) (EXPT (PLUS A 3) 2)
07700 (MINUS (TIMES 2 B))) A);
07800 FF ← '(PLUS (TIMES 2 A B) (MINUS C) D);
07900 FF2 ← '(PLUS (TIMES 2 A B) (MINUS Q) U);
08000 EXPR ROUND(X);
08100 BEGIN NEW XX;
08200 XX ← FIX(X+00.500);
08300 IF XX ≥ 16 THEN
08400 XX← QUOTIENT(XX,10) * 10;
08500 RETURN XX; END;
08600 EXPR SFPRINT(VARS, DEG, C); BEGIN
08700 PJ←0;
08800 RETURN PRINT(FINDOT2(OUTN(SFP(DEG,C,VARS))));
08900 END;
09000 EXPR SFP(DEG,C,VARS);
09100 BEGIN NEW X;
09200 IF NULL(VARS) OR DEG=0 THEN
09300 PJ←PJ+1 ALSO
09400 IF C[PJ] = 0 THEN RETURN NIL
09500 ELSE RETURN C[PJ];
09600 IF LENGTH(VARS)=1 AND C[PJ+1]=0 THEN
09700 PJ←PJ+1 ALSO RETURN SFP(DEG-1, C,VARS);
09800 FOR NEW I←DEG TO 0 BY -1 DO BEGIN
09900 NEW I2; I2←DEG-I+1;
10000 IF I≥1 THEN X[DEG-I+1]←CAR(VARS) CONS I
10100 ELSE X[I2]←NIL;
10200 IF LENGTH(VARS) ≥ 2 THEN BEGIN NEW L;
10300 L←SFP(DEG-I,C,CDR(VARS));
10400 IF L AND X[I2] THEN X[I2]←X[I2] CONS L
10500 ELSE IF L THEN X[I2]←L
10600 ELSE X[I2]←NIL; END;
10700 IF LENGTH(VARS) = 1 THEN BEGIN
10800 PJ←PJ+1;
10900 IF X[I2] AND C[PJ]≠0 THEN X[I2]←X[I2] CONS C[PJ]
11000 ELSE IF C[PJ]≠0 THEN X[I2]←C[PJ];
11100 END; END;
11200 RETURN OUTN(X); END;
11300 EXPR FINDOT(E); BEGIN NEW L;
11400 L←LENGTH(E);
11500 E[L-1]←E[L-1] CONS E[L];
11600 RETURN E ↑ (L-1);
11700 END;
11800 EXPR OUTN(E);
11900 BEGIN NEW M;
12000 IF ATOM(E) THEN RETURN E;
12100 FOR NEW I IN E DO
12200 IF I AND (ATOM(I) OR NOT(ATOM(CAR(I))))
12300 THEN M← I CONS M;
12400 M← REV(M);
12500 RETURN M;
12600 END;
12700 EXPR FINDOT2(E);
12800 BEGIN NEW L;
12900 L←LENGTH(E);
13000 IF L ≤ 1 THEN RETURN E;
13100 IF SUFLIST(E,L) THEN RETURN FINDOT(E);
13200 E[L]←FINDOT2(E[L]);
13300 RETURN E;
13400 END;
13500 EXPR LPOLY(DEG,NV);
13600 IF DEG=0 OR NV=0 THEN 1 ELSE
13700 FOR NEW I←0 TO DEG; PLUS LPOLY(I,NV-1);
13800 EXPR POLY(DEG,NV,VARS);
13900 EREV(POLY2(DEG,NV,VARS));
14000 EXPR POLY2(DEG,NV,VARS);
14100 IF DEG=0 OR NV=0 THEN <1> ELSE
14200 FOR NEW I←0 TO DEG COLLECT
14300 <EXPT(EVAL(CAR(VARS)), DEG-I) * ⊗
14400 POLY(I,NV-1,CDR(VARS))>;
14500 EXPR OUTNIL2(L);
14600 BEGIN NEW M;
14700 IF ATOM(L) THEN RETURN L;
14800 FOR NEW I IN L DO
14900 IF I THEN M←I CONS M; RETURN M; END;
15000 EXPR EREV(L);
15100 IF ATOM(L) THEN L ELSE
15200 FOR NEW I IN L COLLECT IF ATOM(I) THEN <I>
15300 ELSE I;
15400 EXPR REV(L);
15500 IF ATOM(L) OR NULL(CDR(L)) THEN L ELSE
15600 REV(CDR(L)) @ <CAR(L)>;
15700 EXPR ZV(NV,INPUT,VARS);
15800 BEGIN FOR NEW I←1 TO NV DO
15900 SET(VARS[I],0);
16000 RETURN EVAL(INPUT); END;
16100 EXPR FLOAT(X); X+0.00;
16200 EXPR CDREPLACE(E);
16300 FOR NEW I IN E COLLECT
16400 IF I='C OR I='D THEN <I,I>
16500 ELSE <I>;
16600 END.